home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / doio.c < prev    next >
C/C++ Source or Header  |  1998-07-22  |  37KB  |  1,656 lines
  1. /*    doio.c
  2.  *
  3.  *    Copyright (c) 1991-1997, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  */
  9.  
  10. /*
  11.  * "Far below them they saw the white waters pour into a foaming bowl, and
  12.  * then swirl darkly about a deep oval basin in the rocks, until they found
  13.  * their way out again through a narrow gate, and flowed away, fuming and
  14.  * chattering, into calmer and more level reaches."
  15.  */
  16.  
  17. #include "EXTERN.h"
  18. #include "perl.h"
  19.  
  20. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  21. #include <sys/ipc.h>
  22. #ifdef HAS_MSG
  23. #include <sys/msg.h>
  24. #endif
  25. #ifdef HAS_SEM
  26. #include <sys/sem.h>
  27. #endif
  28. #ifdef HAS_SHM
  29. #include <sys/shm.h>
  30. # ifndef HAS_SHMAT_PROTOTYPE
  31.     extern Shmat_t shmat _((int, char *, int));
  32. # endif
  33. #endif
  34. #endif
  35.  
  36. #ifdef I_UTIME
  37. #  if defined(_MSC_VER) || defined(__MINGW32__)
  38. #    include <sys/utime.h>
  39. #  else
  40. #    include <utime.h>
  41. #  endif
  42. #endif
  43.  
  44. #ifdef I_FCNTL
  45. #include <fcntl.h>
  46. #endif
  47. #ifdef I_SYS_FILE
  48. #include <sys/file.h>
  49. #endif
  50. #ifdef O_EXCL
  51. #  define OPEN_EXCL O_EXCL
  52. #else
  53. #  define OPEN_EXCL 0
  54. #endif
  55.  
  56. #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  57. #include <signal.h>
  58. #endif
  59.  
  60. /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  61. #ifdef I_UNISTD
  62. #  include <unistd.h>
  63. #endif
  64.  
  65. #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
  66. # include <sys/socket.h>
  67. # include <netdb.h>
  68. # ifndef ENOTSOCK
  69. #  ifdef I_NET_ERRNO
  70. #   include <net/errno.h>
  71. #  endif
  72. # endif
  73. #endif
  74.  
  75. /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
  76. #ifndef Sock_size_t
  77. #  if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
  78. #    define Sock_size_t Size_t
  79. #  else
  80. #    define Sock_size_t int
  81. #  endif
  82. #endif
  83.  
  84. bool
  85. do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
  86. {
  87.     register IO *io = GvIOn(gv);
  88.     PerlIO *saveifp = Nullfp;
  89.     PerlIO *saveofp = Nullfp;
  90.     char savetype = ' ';
  91.     int writing = 0;
  92.     PerlIO *fp;
  93.     int fd;
  94.     int result;
  95.     bool was_fdopen = FALSE;
  96.  
  97.     PL_forkprocess = 1;        /* assume true if no fork */
  98.  
  99.     if (IoIFP(io)) {
  100.     fd = PerlIO_fileno(IoIFP(io));
  101.     if (IoTYPE(io) == '-')
  102.         result = 0;
  103.     else if (fd <= PL_maxsysfd) {
  104.         saveifp = IoIFP(io);
  105.         saveofp = IoOFP(io);
  106.         savetype = IoTYPE(io);
  107.         result = 0;
  108.     }
  109.     else if (IoTYPE(io) == '|')
  110.         result = PerlProc_pclose(IoIFP(io));
  111.     else if (IoIFP(io) != IoOFP(io)) {
  112.         if (IoOFP(io)) {
  113.         result = PerlIO_close(IoOFP(io));
  114.         PerlIO_close(IoIFP(io));    /* clear stdio, fd already closed */
  115.         }
  116.         else
  117.         result = PerlIO_close(IoIFP(io));
  118.     }
  119.     else
  120.         result = PerlIO_close(IoIFP(io));
  121.     if (result == EOF && fd > PL_maxsysfd)
  122.         PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
  123.           GvENAME(gv));
  124.     IoOFP(io) = IoIFP(io) = Nullfp;
  125.     }
  126.  
  127.     if (as_raw) {
  128.     result = rawmode & 3;
  129.     IoTYPE(io) = "<>++"[result];
  130.     writing = (result > 0);
  131.     fd = PerlLIO_open3(name, rawmode, rawperm);
  132.     if (fd == -1)
  133.         fp = NULL;
  134.     else {
  135.         char *fpmode;
  136.         if (result == 0)
  137.         fpmode = "r";
  138. #ifdef O_APPEND
  139.         else if (rawmode & O_APPEND)
  140.         fpmode = (result == 1) ? "a" : "a+";
  141. #endif
  142.         else
  143.         fpmode = (result == 1) ? "w" : "r+";
  144.         fp = PerlIO_fdopen(fd, fpmode);
  145.         if (!fp)
  146.         PerlLIO_close(fd);
  147.     }
  148.     }
  149.     else {
  150.     char *myname;
  151.     char mode[3];        /* stdio file mode ("r\0" or "r+\0") */
  152.     int dodup;
  153.  
  154.     myname = savepvn(name, len);
  155.     SAVEFREEPV(myname);
  156.     name = myname;
  157.     while (len && isSPACE(name[len-1]))
  158.         name[--len] = '\0';
  159.  
  160.     mode[0] = mode[1] = mode[2] = '\0';
  161.     IoTYPE(io) = *name;
  162.     if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
  163.         mode[1] = *name++;
  164.         --len;
  165.         writing = 1;
  166.     }
  167.  
  168.     if (*name == '|') {
  169.         /*SUPPRESS 530*/
  170.         for (name++; isSPACE(*name); name++) ;
  171.         if (strNE(name,"-"))
  172.         TAINT_ENV();
  173.         TAINT_PROPER("piped open");
  174.         if (name[strlen(name)-1] == '|') {
  175.         name[strlen(name)-1] = '\0' ;
  176.         if (PL_dowarn)
  177.             warn("Can't do bidirectional pipe");
  178.         }
  179.         fp = PerlProc_popen(name,"w");
  180.         writing = 1;
  181.     }
  182.     else if (*name == '>') {
  183.         TAINT_PROPER("open");
  184.         name++;
  185.         if (*name == '>') {
  186.         mode[0] = IoTYPE(io) = 'a';
  187.         name++;
  188.         }
  189.         else
  190.         mode[0] = 'w';
  191.         writing = 1;
  192.  
  193.         if (*name == '&') {
  194.           duplicity:
  195.         dodup = 1;
  196.         name++;
  197.         if (*name == '=') {
  198.             dodup = 0;
  199.             name++;
  200.         }
  201.         if (!*name && supplied_fp)
  202.             fp = supplied_fp;
  203.         else {
  204.             /*SUPPRESS 530*/
  205.             for (; isSPACE(*name); name++) ;
  206.             if (isDIGIT(*name))
  207.             fd = atoi(name);
  208.             else {
  209.             IO* thatio;
  210.             gv = gv_fetchpv(name,FALSE,SVt_PVIO);
  211.             thatio = GvIO(gv);
  212.             if (!thatio) {
  213. #ifdef EINVAL
  214.                 SETERRNO(EINVAL,SS$_IVCHAN);
  215. #endif
  216.                 goto say_false;
  217.             }
  218.             if (IoIFP(thatio)) {
  219.                 fd = PerlIO_fileno(IoIFP(thatio));
  220.                 if (IoTYPE(thatio) == 's')
  221.                 IoTYPE(io) = 's';
  222.             }
  223.             else
  224.                 fd = -1;
  225.             }
  226.             if (dodup)
  227.             fd = PerlLIO_dup(fd);
  228.             else
  229.             was_fdopen = TRUE;
  230.             if (!(fp = PerlIO_fdopen(fd,mode))) {
  231.             if (dodup)
  232.                 PerlLIO_close(fd);
  233.             }
  234.         }
  235.         }
  236.         else {
  237.         /*SUPPRESS 530*/
  238.         for (; isSPACE(*name); name++) ;
  239.         if (strEQ(name,"-")) {
  240.             fp = PerlIO_stdout();
  241.             IoTYPE(io) = '-';
  242.         }
  243.         else  {
  244.             fp = PerlIO_open(name,mode);
  245.         }
  246.         }
  247.     }
  248.     else if (*name == '<') {
  249.         /*SUPPRESS 530*/
  250.         for (name++; isSPACE(*name); name++) ;
  251.         mode[0] = 'r';
  252.         if (*name == '&')
  253.         goto duplicity;
  254.         if (strEQ(name,"-")) {
  255.         fp = PerlIO_stdin();
  256.         IoTYPE(io) = '-';
  257.         }
  258.         else
  259.         fp = PerlIO_open(name,mode);
  260.     }
  261.     else if (len > 1 && name[len-1] == '|') {
  262.         name[--len] = '\0';
  263.         while (len && isSPACE(name[len-1]))
  264.         name[--len] = '\0';
  265.         /*SUPPRESS 530*/
  266.         for (; isSPACE(*name); name++) ;
  267.         if (strNE(name,"-"))
  268.         TAINT_ENV();
  269.         TAINT_PROPER("piped open");
  270.         fp = PerlProc_popen(name,"r");
  271.         IoTYPE(io) = '|';
  272.     }
  273.     else {
  274.         IoTYPE(io) = '<';
  275.         /*SUPPRESS 530*/
  276.         for (; isSPACE(*name); name++) ;
  277.         if (strEQ(name,"-")) {
  278.         fp = PerlIO_stdin();
  279.         IoTYPE(io) = '-';
  280.         }
  281.         else
  282.         fp = PerlIO_open(name,"r");
  283.     }
  284.     }
  285.     if (!fp) {
  286.     if (PL_dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
  287.         warn(warn_nl, "open");
  288.     goto say_false;
  289.     }
  290.     if (IoTYPE(io) &&
  291.       IoTYPE(io) != '|' && IoTYPE(io) != '-') {
  292.     dTHR;
  293.     if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
  294.         (void)PerlIO_close(fp);
  295.         goto say_false;
  296.     }
  297.     if (S_ISSOCK(PL_statbuf.st_mode))
  298.         IoTYPE(io) = 's';    /* in case a socket was passed in to us */
  299. #ifdef HAS_SOCKET
  300.     else if (
  301. #ifdef S_IFMT
  302.         !(PL_statbuf.st_mode & S_IFMT)
  303. #else
  304.         !PL_statbuf.st_mode
  305. #endif
  306.     ) {
  307.         char tmpbuf[256];
  308.         Sock_size_t buflen = sizeof tmpbuf;
  309.         if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
  310.                 &buflen) >= 0
  311.           || errno != ENOTSOCK)
  312.         IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
  313.                 /* but some return 0 for streams too, sigh */
  314.     }
  315. #endif
  316.     }
  317.     if (saveifp) {        /* must use old fp? */
  318.     fd = PerlIO_fileno(saveifp);
  319.     if (saveofp) {
  320.         PerlIO_flush(saveofp);        /* emulate PerlIO_close() */
  321.         if (saveofp != saveifp) {    /* was a socket? */
  322.         PerlIO_close(saveofp);
  323.         if (fd > 2)
  324.             Safefree(saveofp);
  325.         }
  326.     }
  327.     if (fd != PerlIO_fileno(fp)) {
  328.         int pid;
  329.         SV *sv;
  330.  
  331.         PerlLIO_dup2(PerlIO_fileno(fp), fd);
  332.         sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
  333.         (void)SvUPGRADE(sv, SVt_IV);
  334.         pid = SvIVX(sv);
  335.         SvIVX(sv) = 0;
  336.         sv = *av_fetch(PL_fdpid,fd,TRUE);
  337.         (void)SvUPGRADE(sv, SVt_IV);
  338.         SvIVX(sv) = pid;
  339.         if (!was_fdopen)
  340.         PerlIO_close(fp);
  341.  
  342.     }
  343.     fp = saveifp;
  344.     PerlIO_clearerr(fp);
  345.     }
  346. #if defined(HAS_FCNTL) && defined(F_SETFD)
  347.     fd = PerlIO_fileno(fp);
  348.     fcntl(fd,F_SETFD,fd > PL_maxsysfd);
  349. #endif
  350.     IoIFP(io) = fp;
  351.     if (writing) {
  352.     dTHR;
  353.     if (IoTYPE(io) == 's'
  354.       || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) {
  355.         if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
  356.         PerlIO_close(fp);
  357.         IoIFP(io) = Nullfp;
  358.         goto say_false;
  359.         }
  360.     }
  361.     else
  362.         IoOFP(io) = fp;
  363.     }
  364.     return TRUE;
  365.  
  366. say_false:
  367.     IoIFP(io) = saveifp;
  368.     IoOFP(io) = saveofp;
  369.     IoTYPE(io) = savetype;
  370.     return FALSE;
  371. }
  372.  
  373. PerlIO *
  374. nextargv(register GV *gv)
  375. {
  376.     register SV *sv;
  377. #ifndef FLEXFILENAMES
  378.     int filedev;
  379.     int fileino;
  380. #endif
  381.     int fileuid;
  382.     int filegid;
  383.  
  384.     if (!PL_argvoutgv)
  385.     PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
  386.     if (PL_filemode & (S_ISUID|S_ISGID)) {
  387.     PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
  388. #ifdef HAS_FCHMOD
  389.     (void)fchmod(PL_lastfd,PL_filemode);
  390. #else
  391.     (void)PerlLIO_chmod(PL_oldname,PL_filemode);
  392. #endif
  393.     }
  394.     PL_filemode = 0;
  395.     while (av_len(GvAV(gv)) >= 0) {
  396.     dTHR;
  397.     STRLEN oldlen;
  398.     sv = av_shift(GvAV(gv));
  399.     SAVEFREESV(sv);
  400.     sv_setsv(GvSV(gv),sv);
  401.     SvSETMAGIC(GvSV(gv));
  402.     PL_oldname = SvPVx(GvSV(gv), oldlen);
  403.     if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,0,0,Nullfp)) {
  404.         if (PL_inplace) {
  405.         TAINT_PROPER("inplace open");
  406.         if (oldlen == 1 && *PL_oldname == '-') {
  407.             setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
  408.             return IoIFP(GvIOp(gv));
  409.         }
  410. #ifndef FLEXFILENAMES
  411.         filedev = PL_statbuf.st_dev;
  412.         fileino = PL_statbuf.st_ino;
  413. #endif
  414.         PL_filemode = PL_statbuf.st_mode;
  415.         fileuid = PL_statbuf.st_uid;
  416.         filegid = PL_statbuf.st_gid;
  417.         if (!S_ISREG(PL_filemode)) {
  418.             warn("Can't do inplace edit: %s is not a regular file",
  419.               PL_oldname );
  420.             do_close(gv,FALSE);
  421.             continue;
  422.         }
  423.         if (*PL_inplace) {
  424.             char *star = strchr(PL_inplace, '*');
  425.             if (star) {
  426.             char *begin = PL_inplace;
  427.             sv_setpvn(sv, "", 0);
  428.             do {
  429.                 sv_catpvn(sv, begin, star - begin);
  430.                 sv_catpvn(sv, PL_oldname, oldlen);
  431.                 begin = ++star;
  432.             } while ((star = strchr(begin, '*')));
  433.             if (*begin)
  434.                 sv_catpv(sv,begin);
  435.             }
  436.             else {
  437.             sv_catpv(sv,PL_inplace);
  438.             }
  439. #ifndef FLEXFILENAMES
  440.             if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
  441.               && PL_statbuf.st_dev == filedev
  442.               && PL_statbuf.st_ino == fileino
  443. #ifdef DJGPP
  444.                       || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
  445. #endif
  446.                       ) {
  447.             warn("Can't do inplace edit: %s would not be uniq",
  448.               SvPVX(sv) );
  449.             do_close(gv,FALSE);
  450.             continue;
  451.             }
  452. #endif
  453. #ifdef HAS_RENAME
  454. #ifndef DOSISH
  455.             if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
  456.             warn("Can't rename %s to %s: %s, skipping file",
  457.               PL_oldname, SvPVX(sv), Strerror(errno) );
  458.             do_close(gv,FALSE);
  459.             continue;
  460.             }
  461. #else
  462.             do_close(gv,FALSE);
  463.             (void)PerlLIO_unlink(SvPVX(sv));
  464.             (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
  465.             do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,0,0,Nullfp);
  466. #endif /* DOSISH */
  467. #else
  468.             (void)UNLINK(SvPVX(sv));
  469.             if (link(PL_oldname,SvPVX(sv)) < 0) {
  470.             warn("Can't rename %s to %s: %s, skipping file",
  471.               PL_oldname, SvPVX(sv), Strerror(errno) );
  472.             do_close(gv,FALSE);
  473.             continue;
  474.             }
  475.             (void)UNLINK(PL_oldname);
  476. #endif
  477.         }
  478.         else {
  479. #if !defined(DOSISH) && !defined(AMIGAOS)
  480. #  ifndef VMS  /* Don't delete; use automatic file versioning */
  481.             if (UNLINK(PL_oldname) < 0) {
  482.             warn("Can't remove %s: %s, skipping file",
  483.               PL_oldname, Strerror(errno) );
  484.             do_close(gv,FALSE);
  485.             continue;
  486.             }
  487. #  endif
  488. #else
  489.             croak("Can't do inplace edit without backup");
  490. #endif
  491.         }
  492.  
  493.         sv_setpvn(sv,">",!PL_inplace);
  494.         sv_catpvn(sv,PL_oldname,oldlen);
  495.         SETERRNO(0,0);        /* in case sprintf set errno */
  496. #ifdef VMS
  497.         if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
  498.                  O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) { 
  499. #else
  500.         if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
  501.                  O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
  502. #endif
  503.             warn("Can't do inplace edit on %s: %s",
  504.               PL_oldname, Strerror(errno) );
  505.             do_close(gv,FALSE);
  506.             continue;
  507.         }
  508.         setdefout(PL_argvoutgv);
  509.         PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
  510.         (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
  511. #ifdef HAS_FCHMOD
  512.         (void)fchmod(PL_lastfd,PL_filemode);
  513. #else
  514. #  if !(defined(WIN32) && defined(__BORLANDC__))
  515.         /* Borland runtime creates a readonly file! */
  516.         (void)PerlLIO_chmod(PL_oldname,PL_filemode);
  517. #  endif
  518. #endif
  519.         if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
  520. #ifdef HAS_FCHOWN
  521.             (void)fchown(PL_lastfd,fileuid,filegid);
  522. #else
  523. #ifdef HAS_CHOWN
  524.             (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
  525. #endif
  526. #endif
  527.         }
  528.         }
  529.         return IoIFP(GvIOp(gv));
  530.     }
  531.     else
  532.         PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
  533.           SvPV(sv, PL_na), Strerror(errno));
  534.     }
  535.     if (PL_inplace) {
  536.     (void)do_close(PL_argvoutgv,FALSE);
  537.     setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
  538.     }
  539.     return Nullfp;
  540. }
  541.  
  542. #ifdef HAS_PIPE
  543. void
  544. do_pipe(SV *sv, GV *rgv, GV *wgv)
  545. {
  546.     register IO *rstio;
  547.     register IO *wstio;
  548.     int fd[2];
  549.  
  550.     if (!rgv)
  551.     goto badexit;
  552.     if (!wgv)
  553.     goto badexit;
  554.  
  555.     rstio = GvIOn(rgv);
  556.     wstio = GvIOn(wgv);
  557.  
  558.     if (IoIFP(rstio))
  559.     do_close(rgv,FALSE);
  560.     if (IoIFP(wstio))
  561.     do_close(wgv,FALSE);
  562.  
  563.     if (PerlProc_pipe(fd) < 0)
  564.     goto badexit;
  565.     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
  566.     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
  567.     IoIFP(wstio) = IoOFP(wstio);
  568.     IoTYPE(rstio) = '<';
  569.     IoTYPE(wstio) = '>';
  570.     if (!IoIFP(rstio) || !IoOFP(wstio)) {
  571.     if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
  572.     else PerlLIO_close(fd[0]);
  573.     if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
  574.     else PerlLIO_close(fd[1]);
  575.     goto badexit;
  576.     }
  577.  
  578.     sv_setsv(sv,&PL_sv_yes);
  579.     return;
  580.  
  581. badexit:
  582.     sv_setsv(sv,&PL_sv_undef);
  583.     return;
  584. }
  585. #endif
  586.  
  587. /* explicit renamed to avoid C++ conflict    -- kja */
  588. bool
  589. do_close(GV *gv, bool not_implicit)
  590. {
  591.     bool retval;
  592.     IO *io;
  593.  
  594.     if (!gv)
  595.     gv = PL_argvgv;
  596.     if (!gv || SvTYPE(gv) != SVt_PVGV) {
  597.     if (not_implicit)
  598.         SETERRNO(EBADF,SS$_IVCHAN);
  599.     return FALSE;
  600.     }
  601.     io = GvIO(gv);
  602.     if (!io) {        /* never opened */
  603.     if (not_implicit) {
  604.         if (PL_dowarn)
  605.         warn("Close on unopened file <%s>",GvENAME(gv));
  606.         SETERRNO(EBADF,SS$_IVCHAN);
  607.     }
  608.     return FALSE;
  609.     }
  610.     retval = io_close(io);
  611.     if (not_implicit) {
  612.     IoLINES(io) = 0;
  613.     IoPAGE(io) = 0;
  614.     IoLINES_LEFT(io) = IoPAGE_LEN(io);
  615.     }
  616.     IoTYPE(io) = ' ';
  617.     return retval;
  618. }
  619.  
  620. bool
  621. io_close(IO *io)
  622. {
  623.     bool retval = FALSE;
  624.     int status;
  625.  
  626.     if (IoIFP(io)) {
  627.     if (IoTYPE(io) == '|') {
  628.         status = PerlProc_pclose(IoIFP(io));
  629.         STATUS_NATIVE_SET(status);
  630.         retval = (STATUS_POSIX == 0);
  631.     }
  632.     else if (IoTYPE(io) == '-')
  633.         retval = TRUE;
  634.     else {
  635.         if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {        /* a socket */
  636.         retval = (PerlIO_close(IoOFP(io)) != EOF);
  637.         PerlIO_close(IoIFP(io));    /* clear stdio, fd already closed */
  638.         }
  639.         else
  640.         retval = (PerlIO_close(IoIFP(io)) != EOF);
  641.     }
  642.     IoOFP(io) = IoIFP(io) = Nullfp;
  643.     }
  644.     else {
  645.     SETERRNO(EBADF,SS$_IVCHAN);
  646.     }
  647.  
  648.     return retval;
  649. }
  650.  
  651. bool
  652. do_eof(GV *gv)
  653. {
  654.     dTHR;
  655.     register IO *io;
  656.     int ch;
  657.  
  658.     io = GvIO(gv);
  659.  
  660.     if (!io)
  661.     return TRUE;
  662.  
  663.     while (IoIFP(io)) {
  664.  
  665.         if (PerlIO_has_cntptr(IoIFP(io))) {    /* (the code works without this) */
  666.         if (PerlIO_get_cnt(IoIFP(io)) > 0)    /* cheat a little, since */
  667.         return FALSE;            /* this is the most usual case */
  668.         }
  669.  
  670.     ch = PerlIO_getc(IoIFP(io));
  671.     if (ch != EOF) {
  672.         (void)PerlIO_ungetc(IoIFP(io),ch);
  673.         return FALSE;
  674.     }
  675.         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
  676.         if (PerlIO_get_cnt(IoIFP(io)) < -1)
  677.         PerlIO_set_cnt(IoIFP(io),-1);
  678.     }
  679.     if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
  680.         if (!nextargv(PL_argvgv))    /* get another fp handy */
  681.         return TRUE;
  682.     }
  683.     else
  684.         return TRUE;        /* normal fp, definitely end of file */
  685.     }
  686.     return TRUE;
  687. }
  688.  
  689. long
  690. do_tell(GV *gv)
  691. {
  692.     register IO *io;
  693.     register PerlIO *fp;
  694.  
  695.     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
  696. #ifdef ULTRIX_STDIO_BOTCH
  697.     if (PerlIO_eof(fp))
  698.         (void)PerlIO_seek(fp, 0L, 2);    /* ultrix 1.2 workaround */
  699. #endif
  700.     return PerlIO_tell(fp);
  701.     }
  702.     if (PL_dowarn)
  703.     warn("tell() on unopened file");
  704.     SETERRNO(EBADF,RMS$_IFI);
  705.     return -1L;
  706. }
  707.  
  708. bool
  709. do_seek(GV *gv, long int pos, int whence)
  710. {
  711.     register IO *io;
  712.     register PerlIO *fp;
  713.  
  714.     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
  715. #ifdef ULTRIX_STDIO_BOTCH
  716.     if (PerlIO_eof(fp))
  717.         (void)PerlIO_seek(fp, 0L, 2);    /* ultrix 1.2 workaround */
  718. #endif
  719.     return PerlIO_seek(fp, pos, whence) >= 0;
  720.     }
  721.     if (PL_dowarn)
  722.     warn("seek() on unopened file");
  723.     SETERRNO(EBADF,RMS$_IFI);
  724.     return FALSE;
  725. }
  726.  
  727. long
  728. do_sysseek(GV *gv, long int pos, int whence)
  729. {
  730.     register IO *io;
  731.     register PerlIO *fp;
  732.  
  733.     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
  734.     return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
  735.     if (PL_dowarn)
  736.     warn("sysseek() on unopened file");
  737.     SETERRNO(EBADF,RMS$_IFI);
  738.     return -1L;
  739. }
  740.  
  741. int
  742. do_binmode(PerlIO *fp, int iotype, int flag)
  743. {
  744.     if (flag != TRUE)
  745.     croak("panic: unsetting binmode"); /* Not implemented yet */
  746. #ifdef DOSISH
  747. #ifdef atarist
  748.     if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
  749.     return 1;
  750.     else
  751.     return 0;
  752. #else
  753.     if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
  754. #if defined(WIN32) && defined(__BORLANDC__)
  755.     /* The translation mode of the stream is maintained independent
  756.      * of the translation mode of the fd in the Borland RTL (heavy
  757.      * digging through their runtime sources reveal).  User has to
  758.      * set the mode explicitly for the stream (though they don't
  759.      * document this anywhere). GSAR 97-5-24
  760.      */
  761.     PerlIO_seek(fp,0L,0);
  762.     ((FILE*)fp)->flags |= _F_BIN;
  763. #endif
  764.     return 1;
  765.     }
  766.     else
  767.     return 0;
  768. #endif
  769. #else
  770. #if defined(USEMYBINMODE)
  771.     if (my_binmode(fp,iotype) != NULL)
  772.     return 1;
  773.     else
  774.     return 0;
  775. #else
  776.     return 1;
  777. #endif
  778. #endif
  779. }
  780.  
  781. #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
  782.     /* code courtesy of William Kucharski */
  783. #define HAS_CHSIZE
  784.  
  785. I32 my_chsize(fd, length)
  786. I32 fd;            /* file descriptor */
  787. Off_t length;        /* length to set file to */
  788. {
  789.     struct flock fl;
  790.     struct stat filebuf;
  791.  
  792.     if (PerlLIO_fstat(fd, &filebuf) < 0)
  793.     return -1;
  794.  
  795.     if (filebuf.st_size < length) {
  796.  
  797.     /* extend file length */
  798.  
  799.     if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
  800.         return -1;
  801.  
  802.     /* write a "0" byte */
  803.  
  804.     if ((PerlLIO_write(fd, "", 1)) != 1)
  805.         return -1;
  806.     }
  807.     else {
  808.     /* truncate length */
  809.  
  810.     fl.l_whence = 0;
  811.     fl.l_len = 0;
  812.     fl.l_start = length;
  813.     fl.l_type = F_WRLCK;    /* write lock on file space */
  814.  
  815.     /*
  816.     * This relies on the UNDOCUMENTED F_FREESP argument to
  817.     * fcntl(2), which truncates the file so that it ends at the
  818.     * position indicated by fl.l_start.
  819.     *
  820.     * Will minor miracles never cease?
  821.     */
  822.  
  823.     if (fcntl(fd, F_FREESP, &fl) < 0)
  824.         return -1;
  825.  
  826.     }
  827.  
  828.     return 0;
  829. }
  830. #endif /* F_FREESP */
  831.  
  832. bool
  833. do_print(register SV *sv, PerlIO *fp)
  834. {
  835.     register char *tmps;
  836.     STRLEN len;
  837.  
  838.     /* assuming fp is checked earlier */
  839.     if (!sv)
  840.     return TRUE;
  841.     if (PL_ofmt) {
  842.     if (SvGMAGICAL(sv))
  843.         mg_get(sv);
  844.         if (SvIOK(sv) && SvIVX(sv) != 0) {
  845.         PerlIO_printf(fp, PL_ofmt, (double)SvIVX(sv));
  846.         return !PerlIO_error(fp);
  847.     }
  848.     if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
  849.        || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
  850.         PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
  851.         return !PerlIO_error(fp);
  852.     }
  853.     }
  854.     switch (SvTYPE(sv)) {
  855.     case SVt_NULL:
  856.     if (PL_dowarn)
  857.         warn(warn_uninit);
  858.     return TRUE;
  859.     case SVt_IV:
  860.     if (SvIOK(sv)) {
  861.         if (SvGMAGICAL(sv))
  862.         mg_get(sv);
  863.         PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
  864.         return !PerlIO_error(fp);
  865.     }
  866.     /* FALL THROUGH */
  867.     default:
  868.     tmps = SvPV(sv, len);
  869.     break;
  870.     }
  871.     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
  872.     return FALSE;
  873.     return !PerlIO_error(fp);
  874. }
  875.  
  876. I32
  877. my_stat(ARGSproto)
  878. {
  879.     djSP;
  880.     IO *io;
  881.     GV* tmpgv;
  882.  
  883.     if (PL_op->op_flags & OPf_REF) {
  884.     EXTEND(SP,1);
  885.     tmpgv = cGVOP->op_gv;
  886.       do_fstat:
  887.     io = GvIO(tmpgv);
  888.     if (io && IoIFP(io)) {
  889.         PL_statgv = tmpgv;
  890.         sv_setpv(PL_statname,"");
  891.         PL_laststype = OP_STAT;
  892.         return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
  893.     }
  894.     else {
  895.         if (tmpgv == PL_defgv)
  896.         return PL_laststatval;
  897.         if (PL_dowarn)
  898.         warn("Stat on unopened file <%s>",
  899.           GvENAME(tmpgv));
  900.         PL_statgv = Nullgv;
  901.         sv_setpv(PL_statname,"");
  902.         return (PL_laststatval = -1);
  903.     }
  904.     }
  905.     else {
  906.     SV* sv = POPs;
  907.     char *s;
  908.     PUTBACK;
  909.     if (SvTYPE(sv) == SVt_PVGV) {
  910.         tmpgv = (GV*)sv;
  911.         goto do_fstat;
  912.     }
  913.     else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
  914.         tmpgv = (GV*)SvRV(sv);
  915.         goto do_fstat;
  916.     }
  917.  
  918.     s = SvPV(sv, PL_na);
  919.     PL_statgv = Nullgv;
  920.     sv_setpv(PL_statname, s);
  921.     PL_laststype = OP_STAT;
  922.     PL_laststatval = PerlLIO_stat(s, &PL_statcache);
  923.     if (PL_laststatval < 0 && PL_dowarn && strchr(s, '\n'))
  924.         warn(warn_nl, "stat");
  925.     return PL_laststatval;
  926.     }
  927. }
  928.  
  929. I32
  930. my_lstat(ARGSproto)
  931. {
  932.     djSP;
  933.     SV *sv;
  934.     if (PL_op->op_flags & OPf_REF) {
  935.     EXTEND(SP,1);
  936.     if (cGVOP->op_gv == PL_defgv) {
  937.         if (PL_laststype != OP_LSTAT)
  938.         croak("The stat preceding -l _ wasn't an lstat");
  939.         return PL_laststatval;
  940.     }
  941.     croak("You can't use -l on a filehandle");
  942.     }
  943.  
  944.     PL_laststype = OP_LSTAT;
  945.     PL_statgv = Nullgv;
  946.     sv = POPs;
  947.     PUTBACK;
  948.     sv_setpv(PL_statname,SvPV(sv, PL_na));
  949. #ifdef HAS_LSTAT
  950.     PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache);
  951. #else
  952.     PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache);
  953. #endif
  954.     if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
  955.     warn(warn_nl, "lstat");
  956.     return PL_laststatval;
  957. }
  958.  
  959. bool
  960. do_aexec(SV *really, register SV **mark, register SV **sp)
  961. {
  962.     register char **a;
  963.     char *tmps;
  964.  
  965.     if (sp > mark) {
  966.     dTHR;
  967.     New(401,PL_Argv, sp - mark + 1, char*);
  968.     a = PL_Argv;
  969.     while (++mark <= sp) {
  970.         if (*mark)
  971.         *a++ = SvPVx(*mark, PL_na);
  972.         else
  973.         *a++ = "";
  974.     }
  975.     *a = Nullch;
  976.     if (*PL_Argv[0] != '/')    /* will execvp use PATH? */
  977.         TAINT_ENV();        /* testing IFS here is overkill, probably */
  978.     if (really && *(tmps = SvPV(really, PL_na)))
  979.         PerlProc_execvp(tmps,PL_Argv);
  980.     else
  981.         PerlProc_execvp(PL_Argv[0],PL_Argv);
  982.     if (PL_dowarn)
  983.         warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
  984.     }
  985.     do_execfree();
  986.     return FALSE;
  987. }
  988.  
  989. void
  990. do_execfree(void)
  991. {
  992.     if (PL_Argv) {
  993.     Safefree(PL_Argv);
  994.     PL_Argv = Null(char **);
  995.     }
  996.     if (PL_Cmd) {
  997.     Safefree(PL_Cmd);
  998.     PL_Cmd = Nullch;
  999.     }
  1000. }
  1001.  
  1002. #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
  1003.  
  1004. bool
  1005. do_exec(char *cmd)
  1006. {
  1007.     register char **a;
  1008.     register char *s;
  1009.     char flags[10];
  1010.  
  1011.     while (*cmd && isSPACE(*cmd))
  1012.     cmd++;
  1013.  
  1014.     /* save an extra exec if possible */
  1015.  
  1016. #ifdef CSH
  1017.     if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
  1018.     strcpy(flags,"-c");
  1019.     s = cmd+PL_cshlen+3;
  1020.     if (*s == 'f') {
  1021.         s++;
  1022.         strcat(flags,"f");
  1023.     }
  1024.     if (*s == ' ')
  1025.         s++;
  1026.     if (*s++ == '\'') {
  1027.         char *ncmd = s;
  1028.  
  1029.         while (*s)
  1030.         s++;
  1031.         if (s[-1] == '\n')
  1032.         *--s = '\0';
  1033.         if (s[-1] == '\'') {
  1034.         *--s = '\0';
  1035.         PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
  1036.         *s = '\'';
  1037.         return FALSE;
  1038.         }
  1039.     }
  1040.     }
  1041. #endif /* CSH */
  1042.  
  1043.     /* see if there are shell metacharacters in it */
  1044.  
  1045.     if (*cmd == '.' && isSPACE(cmd[1]))
  1046.     goto doshell;
  1047.  
  1048.     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
  1049.     goto doshell;
  1050.  
  1051.     for (s = cmd; *s && isALPHA(*s); s++) ;    /* catch VAR=val gizmo */
  1052.     if (*s == '=')
  1053.     goto doshell;
  1054.  
  1055.     for (s = cmd; *s; s++) {
  1056.     if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
  1057.         if (*s == '\n' && !s[1]) {
  1058.         *s = '\0';
  1059.         break;
  1060.         }
  1061.       doshell:
  1062.         PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
  1063.         return FALSE;
  1064.     }
  1065.     }
  1066.  
  1067.     New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
  1068.     PL_Cmd = savepvn(cmd, s-cmd);
  1069.     a = PL_Argv;
  1070.     for (s = PL_Cmd; *s;) {
  1071.     while (*s && isSPACE(*s)) s++;
  1072.     if (*s)
  1073.         *(a++) = s;
  1074.     while (*s && !isSPACE(*s)) s++;
  1075.     if (*s)
  1076.         *s++ = '\0';
  1077.     }
  1078.     *a = Nullch;
  1079.     if (PL_Argv[0]) {
  1080.     PerlProc_execvp(PL_Argv[0],PL_Argv);
  1081.     if (errno == ENOEXEC) {        /* for system V NIH syndrome */
  1082.         do_execfree();
  1083.         goto doshell;
  1084.     }
  1085.     if (PL_dowarn)
  1086.         warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
  1087.     }
  1088.     do_execfree();
  1089.     return FALSE;
  1090. }
  1091.  
  1092. #endif /* OS2 || WIN32 */
  1093.  
  1094. I32
  1095. apply(I32 type, register SV **mark, register SV **sp)
  1096. {
  1097.     dTHR;
  1098.     register I32 val;
  1099.     register I32 val2;
  1100.     register I32 tot = 0;
  1101.     char *what;
  1102.     char *s;
  1103.     SV **oldmark = mark;
  1104.  
  1105. #define APPLY_TAINT_PROPER() \
  1106.     STMT_START {                            \
  1107.     if (PL_tainting && PL_tainted) { goto taint_proper_label; }    \
  1108.     } STMT_END
  1109.  
  1110.     /* This is a first heuristic; it doesn't catch tainting magic. */
  1111.     if (PL_tainting) {
  1112.     while (++mark <= sp) {
  1113.         if (SvTAINTED(*mark)) {
  1114.         TAINT;
  1115.         break;
  1116.         }
  1117.     }
  1118.     mark = oldmark;
  1119.     }
  1120.     switch (type) {
  1121.     case OP_CHMOD:
  1122.     what = "chmod";
  1123.     APPLY_TAINT_PROPER();
  1124.     if (++mark <= sp) {
  1125.         val = SvIVx(*mark);
  1126.         APPLY_TAINT_PROPER();
  1127.         tot = sp - mark;
  1128.         while (++mark <= sp) {
  1129.         char *name = SvPVx(*mark, PL_na);
  1130.         APPLY_TAINT_PROPER();
  1131.         if (PerlLIO_chmod(name, val))
  1132.             tot--;
  1133.         }
  1134.     }
  1135.     break;
  1136. #ifdef HAS_CHOWN
  1137.     case OP_CHOWN:
  1138.     what = "chown";
  1139.     APPLY_TAINT_PROPER();
  1140.     if (sp - mark > 2) {
  1141.         val = SvIVx(*++mark);
  1142.         val2 = SvIVx(*++mark);
  1143.         APPLY_TAINT_PROPER();
  1144.         tot = sp - mark;
  1145.         while (++mark <= sp) {
  1146.         char *name = SvPVx(*mark, PL_na);
  1147.         APPLY_TAINT_PROPER();
  1148.         if (PerlLIO_chown(name, val, val2))
  1149.             tot--;
  1150.         }
  1151.     }
  1152.     break;
  1153. #endif
  1154. /* 
  1155. XXX Should we make lchown() directly available from perl?
  1156. For now, we'll let Configure test for HAS_LCHOWN, but do
  1157. nothing in the core.
  1158.     --AD  5/1998
  1159. */
  1160. #ifdef HAS_KILL
  1161.     case OP_KILL:
  1162.     what = "kill";
  1163.     APPLY_TAINT_PROPER();
  1164.     if (mark == sp)
  1165.         break;
  1166.     s = SvPVx(*++mark, PL_na);
  1167.     if (isUPPER(*s)) {
  1168.         if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
  1169.         s += 3;
  1170.         if (!(val = whichsig(s)))
  1171.         croak("Unrecognized signal name \"%s\"",s);
  1172.     }
  1173.     else
  1174.         val = SvIVx(*mark);
  1175.     APPLY_TAINT_PROPER();
  1176.     tot = sp - mark;
  1177. #ifdef VMS
  1178.     /* kill() doesn't do process groups (job trees?) under VMS */
  1179.     if (val < 0) val = -val;
  1180.     if (val == SIGKILL) {
  1181. #        include <starlet.h>
  1182.         /* Use native sys$delprc() to insure that target process is
  1183.          * deleted; supervisor-mode images don't pay attention to
  1184.          * CRTL's emulation of Unix-style signals and kill()
  1185.          */
  1186.         while (++mark <= sp) {
  1187.         I32 proc = SvIVx(*mark);
  1188.         register unsigned long int __vmssts;
  1189.         APPLY_TAINT_PROPER();
  1190.         if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
  1191.             tot--;
  1192.             switch (__vmssts) {
  1193.             case SS$_NONEXPR:
  1194.             case SS$_NOSUCHNODE:
  1195.                 SETERRNO(ESRCH,__vmssts);
  1196.                 break;
  1197.             case SS$_NOPRIV:
  1198.                 SETERRNO(EPERM,__vmssts);
  1199.                 break;
  1200.             default:
  1201.                 SETERRNO(EVMSERR,__vmssts);
  1202.             }
  1203.         }
  1204.         }
  1205.         break;
  1206.     }
  1207. #endif
  1208.     if (val < 0) {
  1209.         val = -val;
  1210.         while (++mark <= sp) {
  1211.         I32 proc = SvIVx(*mark);
  1212.         APPLY_TAINT_PROPER();
  1213. #ifdef HAS_KILLPG
  1214.         if (PerlProc_killpg(proc,val))    /* BSD */
  1215. #else
  1216.         if (PerlProc_kill(-proc,val))    /* SYSV */
  1217. #endif
  1218.             tot--;
  1219.         }
  1220.     }
  1221.     else {
  1222.         while (++mark <= sp) {
  1223.         I32 proc = SvIVx(*mark);
  1224.         APPLY_TAINT_PROPER();
  1225.         if (PerlProc_kill(proc, val))
  1226.             tot--;
  1227.         }
  1228.     }
  1229.     break;
  1230. #endif
  1231.     case OP_UNLINK:
  1232.     what = "unlink";
  1233.     APPLY_TAINT_PROPER();
  1234.     tot = sp - mark;
  1235.     while (++mark <= sp) {
  1236.         s = SvPVx(*mark, PL_na);
  1237.         APPLY_TAINT_PROPER();
  1238.         if (PL_euid || PL_unsafe) {
  1239.         if (UNLINK(s))
  1240.             tot--;
  1241.         }
  1242.         else {    /* don't let root wipe out directories without -U */
  1243. #ifdef HAS_LSTAT
  1244.         if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
  1245. #else
  1246.         if (PerlLIO_stat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
  1247. #endif
  1248.             tot--;
  1249.         else {
  1250.             if (UNLINK(s))
  1251.             tot--;
  1252.         }
  1253.         }
  1254.     }
  1255.     break;
  1256. #ifdef HAS_UTIME
  1257.     case OP_UTIME:
  1258.     what = "utime";
  1259.     APPLY_TAINT_PROPER();
  1260.     if (sp - mark > 2) {
  1261. #if defined(I_UTIME) || defined(VMS)
  1262.         struct utimbuf utbuf;
  1263. #else
  1264.         struct {
  1265.         long    actime;
  1266.         long    modtime;
  1267.         } utbuf;
  1268. #endif
  1269.  
  1270.         Zero(&utbuf, sizeof utbuf, char);
  1271. #ifdef BIG_TIME
  1272.         utbuf.actime = (Time_t)SvNVx(*++mark);    /* time accessed */
  1273.         utbuf.modtime = (Time_t)SvNVx(*++mark);    /* time modified */
  1274. #else
  1275.         utbuf.actime = SvIVx(*++mark);    /* time accessed */
  1276.         utbuf.modtime = SvIVx(*++mark);    /* time modified */
  1277. #endif
  1278.         APPLY_TAINT_PROPER();
  1279.         tot = sp - mark;
  1280.         while (++mark <= sp) {
  1281.         char *name = SvPVx(*mark, PL_na);
  1282.         APPLY_TAINT_PROPER();
  1283.         if (PerlLIO_utime(name, &utbuf))
  1284.             tot--;
  1285.         }
  1286.     }
  1287.     else
  1288.         tot = 0;
  1289.     break;
  1290. #endif
  1291.     }
  1292.     return tot;
  1293.  
  1294.   taint_proper_label:
  1295.     TAINT_PROPER(what);
  1296.     return 0;    /* this should never happen */
  1297.  
  1298. #undef APPLY_TAINT_PROPER
  1299. }
  1300.  
  1301. /* Do the permissions allow some operation?  Assumes statcache already set. */
  1302. #ifndef VMS /* VMS' cando is in vms.c */
  1303. I32
  1304. cando(I32 bit, I32 effective, register struct stat *statbufp)
  1305. {
  1306. #ifdef DOSISH
  1307.     /* [Comments and code from Len Reed]
  1308.      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
  1309.      * to write-protected files.  The execute permission bit is set
  1310.      * by the Miscrosoft C library stat() function for the following:
  1311.      *        .exe files
  1312.      *        .com files
  1313.      *        .bat files
  1314.      *        directories
  1315.      * All files and directories are readable.
  1316.      * Directories and special files, e.g. "CON", cannot be
  1317.      * write-protected.
  1318.      * [Comment by Tom Dinger -- a directory can have the write-protect
  1319.      *        bit set in the file system, but DOS permits changes to
  1320.      *        the directory anyway.  In addition, all bets are off
  1321.      *        here for networked software, such as Novell and
  1322.      *        Sun's PC-NFS.]
  1323.      */
  1324.  
  1325.      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
  1326.       * too so it will actually look into the files for magic numbers
  1327.       */
  1328.      return (bit & statbufp->st_mode) ? TRUE : FALSE;
  1329.  
  1330. #else /* ! DOSISH */
  1331.     if ((effective ? PL_euid : PL_uid) == 0) {    /* root is special */
  1332.     if (bit == S_IXUSR) {
  1333.         if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
  1334.         return TRUE;
  1335.     }
  1336.     else
  1337.         return TRUE;        /* root reads and writes anything */
  1338.     return FALSE;
  1339.     }
  1340.     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
  1341.     if (statbufp->st_mode & bit)
  1342.         return TRUE;    /* ok as "user" */
  1343.     }
  1344.     else if (ingroup((I32)statbufp->st_gid,effective)) {
  1345.     if (statbufp->st_mode & bit >> 3)
  1346.         return TRUE;    /* ok as "group" */
  1347.     }
  1348.     else if (statbufp->st_mode & bit >> 6)
  1349.     return TRUE;    /* ok as "other" */
  1350.     return FALSE;
  1351. #endif /* ! DOSISH */
  1352. }
  1353. #endif /* ! VMS */
  1354.  
  1355. I32
  1356. ingroup(I32 testgid, I32 effective)
  1357. {
  1358.     if (testgid == (effective ? PL_egid : PL_gid))
  1359.     return TRUE;
  1360. #ifdef HAS_GETGROUPS
  1361. #ifndef NGROUPS
  1362. #define NGROUPS 32
  1363. #endif
  1364.     {
  1365.     Groups_t gary[NGROUPS];
  1366.     I32 anum;
  1367.  
  1368.     anum = getgroups(NGROUPS,gary);
  1369.     while (--anum >= 0)
  1370.         if (gary[anum] == testgid)
  1371.         return TRUE;
  1372.     }
  1373. #endif
  1374.     return FALSE;
  1375. }
  1376.  
  1377. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  1378.  
  1379. I32
  1380. do_ipcget(I32 optype, SV **mark, SV **sp)
  1381. {
  1382.     dTHR;
  1383.     key_t key;
  1384.     I32 n, flags;
  1385.  
  1386.     key = (key_t)SvNVx(*++mark);
  1387.     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
  1388.     flags = SvIVx(*++mark);
  1389.     SETERRNO(0,0);
  1390.     switch (optype)
  1391.     {
  1392. #ifdef HAS_MSG
  1393.     case OP_MSGGET:
  1394.     return msgget(key, flags);
  1395. #endif
  1396. #ifdef HAS_SEM
  1397.     case OP_SEMGET:
  1398.     return semget(key, n, flags);
  1399. #endif
  1400. #ifdef HAS_SHM
  1401.     case OP_SHMGET:
  1402.     return shmget(key, n, flags);
  1403. #endif
  1404. #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
  1405.     default:
  1406.     croak("%s not implemented", op_desc[optype]);
  1407. #endif
  1408.     }
  1409.     return -1;            /* should never happen */
  1410. }
  1411.  
  1412. I32
  1413. do_ipcctl(I32 optype, SV **mark, SV **sp)
  1414. {
  1415.     dTHR;
  1416.     SV *astr;
  1417.     char *a;
  1418.     I32 id, n, cmd, infosize, getinfo;
  1419.     I32 ret = -1;
  1420.  
  1421.     id = SvIVx(*++mark);
  1422.     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
  1423.     cmd = SvIVx(*++mark);
  1424.     astr = *++mark;
  1425.     infosize = 0;
  1426.     getinfo = (cmd == IPC_STAT);
  1427.  
  1428.     switch (optype)
  1429.     {
  1430. #ifdef HAS_MSG
  1431.     case OP_MSGCTL:
  1432.     if (cmd == IPC_STAT || cmd == IPC_SET)
  1433.         infosize = sizeof(struct msqid_ds);
  1434.     break;
  1435. #endif
  1436. #ifdef HAS_SHM
  1437.     case OP_SHMCTL:
  1438.     if (cmd == IPC_STAT || cmd == IPC_SET)
  1439.         infosize = sizeof(struct shmid_ds);
  1440.     break;
  1441. #endif
  1442. #ifdef HAS_SEM
  1443.     case OP_SEMCTL:
  1444.     if (cmd == IPC_STAT || cmd == IPC_SET)
  1445.         infosize = sizeof(struct semid_ds);
  1446.     else if (cmd == GETALL || cmd == SETALL)
  1447.     {
  1448.         struct semid_ds semds;
  1449.         union semun semun;
  1450.  
  1451.             semun.buf = &semds;
  1452.         getinfo = (cmd == GETALL);
  1453.         if (Semctl(id, 0, IPC_STAT, semun) == -1)
  1454.         return -1;
  1455.         infosize = semds.sem_nsems * sizeof(short);
  1456.         /* "short" is technically wrong but much more portable
  1457.            than guessing about u_?short(_t)? */
  1458.     }
  1459.     break;
  1460. #endif
  1461. #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
  1462.     default:
  1463.     croak("%s not implemented", op_desc[optype]);
  1464. #endif
  1465.     }
  1466.  
  1467.     if (infosize)
  1468.     {
  1469.     STRLEN len;
  1470.     if (getinfo)
  1471.     {
  1472.         SvPV_force(astr, len);
  1473.         a = SvGROW(astr, infosize+1);
  1474.     }
  1475.     else
  1476.     {
  1477.         a = SvPV(astr, len);
  1478.         if (len != infosize)
  1479.         croak("Bad arg length for %s, is %lu, should be %ld",
  1480.             op_desc[optype], (unsigned long)len, (long)infosize);
  1481.     }
  1482.     }
  1483.     else
  1484.     {
  1485.     IV i = SvIV(astr);
  1486.     a = (char *)i;        /* ouch */
  1487.     }
  1488.     SETERRNO(0,0);
  1489.     switch (optype)
  1490.     {
  1491. #ifdef HAS_MSG
  1492.     case OP_MSGCTL:
  1493.     ret = msgctl(id, cmd, (struct msqid_ds *)a);
  1494.     break;
  1495. #endif
  1496. #ifdef HAS_SEM
  1497.     case OP_SEMCTL: {
  1498.             union semun unsemds;
  1499.  
  1500.             unsemds.buf = (struct semid_ds *)a;
  1501.         ret = Semctl(id, n, cmd, unsemds);
  1502.         }
  1503.     break;
  1504. #endif
  1505. #ifdef HAS_SHM
  1506.     case OP_SHMCTL:
  1507.     ret = shmctl(id, cmd, (struct shmid_ds *)a);
  1508.     break;
  1509. #endif
  1510.     }
  1511.     if (getinfo && ret >= 0) {
  1512.     SvCUR_set(astr, infosize);
  1513.     *SvEND(astr) = '\0';
  1514.     SvSETMAGIC(astr);
  1515.     }
  1516.     return ret;
  1517. }
  1518.  
  1519. I32
  1520. do_msgsnd(SV **mark, SV **sp)
  1521. {
  1522. #ifdef HAS_MSG
  1523.     dTHR;
  1524.     SV *mstr;
  1525.     char *mbuf;
  1526.     I32 id, msize, flags;
  1527.     STRLEN len;
  1528.  
  1529.     id = SvIVx(*++mark);
  1530.     mstr = *++mark;
  1531.     flags = SvIVx(*++mark);
  1532.     mbuf = SvPV(mstr, len);
  1533.     if ((msize = len - sizeof(long)) < 0)
  1534.     croak("Arg too short for msgsnd");
  1535.     SETERRNO(0,0);
  1536.     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
  1537. #else
  1538.     croak("msgsnd not implemented");
  1539. #endif
  1540. }
  1541.  
  1542. I32
  1543. do_msgrcv(SV **mark, SV **sp)
  1544. {
  1545. #ifdef HAS_MSG
  1546.     dTHR;
  1547.     SV *mstr;
  1548.     char *mbuf;
  1549.     long mtype;
  1550.     I32 id, msize, flags, ret;
  1551.     STRLEN len;
  1552.  
  1553.     id = SvIVx(*++mark);
  1554.     mstr = *++mark;
  1555.     msize = SvIVx(*++mark);
  1556.     mtype = (long)SvIVx(*++mark);
  1557.     flags = SvIVx(*++mark);
  1558.     if (SvTHINKFIRST(mstr)) {
  1559.     if (SvREADONLY(mstr))
  1560.         croak("Can't msgrcv to readonly var");
  1561.     if (SvROK(mstr))
  1562.         sv_unref(mstr);
  1563.     }
  1564.     SvPV_force(mstr, len);
  1565.     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
  1566.     
  1567.     SETERRNO(0,0);
  1568.     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
  1569.     if (ret >= 0) {
  1570.     SvCUR_set(mstr, sizeof(long)+ret);
  1571.     *SvEND(mstr) = '\0';
  1572.     }
  1573.     return ret;
  1574. #else
  1575.     croak("msgrcv not implemented");
  1576. #endif
  1577. }
  1578.  
  1579. I32
  1580. do_semop(SV **mark, SV **sp)
  1581. {
  1582. #ifdef HAS_SEM
  1583.     dTHR;
  1584.     SV *opstr;
  1585.     char *opbuf;
  1586.     I32 id;
  1587.     STRLEN opsize;
  1588.  
  1589.     id = SvIVx(*++mark);
  1590.     opstr = *++mark;
  1591.     opbuf = SvPV(opstr, opsize);
  1592.     if (opsize < sizeof(struct sembuf)
  1593.     || (opsize % sizeof(struct sembuf)) != 0) {
  1594.     SETERRNO(EINVAL,LIB$_INVARG);
  1595.     return -1;
  1596.     }
  1597.     SETERRNO(0,0);
  1598.     return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
  1599. #else
  1600.     croak("semop not implemented");
  1601. #endif
  1602. }
  1603.  
  1604. I32
  1605. do_shmio(I32 optype, SV **mark, SV **sp)
  1606. {
  1607. #ifdef HAS_SHM
  1608.     dTHR;
  1609.     SV *mstr;
  1610.     char *mbuf, *shm;
  1611.     I32 id, mpos, msize;
  1612.     STRLEN len;
  1613.     struct shmid_ds shmds;
  1614.  
  1615.     id = SvIVx(*++mark);
  1616.     mstr = *++mark;
  1617.     mpos = SvIVx(*++mark);
  1618.     msize = SvIVx(*++mark);
  1619.     SETERRNO(0,0);
  1620.     if (shmctl(id, IPC_STAT, &shmds) == -1)
  1621.     return -1;
  1622.     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
  1623.     SETERRNO(EFAULT,SS$_ACCVIO);        /* can't do as caller requested */
  1624.     return -1;
  1625.     }
  1626.     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
  1627.     if (shm == (char *)-1)    /* I hate System V IPC, I really do */
  1628.     return -1;
  1629.     if (optype == OP_SHMREAD) {
  1630.     SvPV_force(mstr, len);
  1631.     mbuf = SvGROW(mstr, msize+1);
  1632.  
  1633.     Copy(shm + mpos, mbuf, msize, char);
  1634.     SvCUR_set(mstr, msize);
  1635.     *SvEND(mstr) = '\0';
  1636.     SvSETMAGIC(mstr);
  1637.     }
  1638.     else {
  1639.     I32 n;
  1640.  
  1641.     mbuf = SvPV(mstr, len);
  1642.     if ((n = len) > msize)
  1643.         n = msize;
  1644.     Copy(mbuf, shm + mpos, n, char);
  1645.     if (n < msize)
  1646.         memzero(shm + mpos + n, msize - n);
  1647.     }
  1648.     return shmdt(shm);
  1649. #else
  1650.     croak("shm I/O not implemented");
  1651. #endif
  1652. }
  1653.  
  1654. #endif /* SYSV IPC */
  1655.  
  1656.